home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 03 - 1987 / 03.09 Sep 87 / fortran source / printgraph source / PrintGraph.for < prev    next >
Encoding:
Text File  |  1987-08-09  |  13.1 KB  |  563 lines  |  [TEXT/EDIT]
  1. * Listing 7
  2. * file:  PrintGraph.for
  3.  
  4.  
  5. *
  6. * PrintGraph Fortran Program
  7. *
  8. * Copyright (c) 1987 Mark E. McBride
  9. *                    211 N. University Ave.
  10. *                    Oxford, OH  45056
  11. *
  12. *
  13. * Main Program
  14. *
  15.     program PrintGraph
  16.     
  17.     implicit none            ! helps keep us out of trouble
  18.  
  19. *
  20. * Reset the pathname to reflect your disk setup
  21. *
  22.     include XP40-6:MS Fortran:Include Files:desk.inc
  23.     include XP40-6:MS Fortran:Include Files:dialog.inc
  24.     include XP40-6:MS Fortran:Include Files:event.inc
  25.     include XP40-6:MS Fortran:Include Files:menu.inc
  26.     include XP40-6:MS Fortran:Include Files:memory.inc
  27.     include XP40-6:MS Fortran:Include Files:misc.inc
  28.     include XP40-6:MS Fortran:Include Files:quickdraw.inc
  29.     include XP40-6:MS Fortran:Include Files:textedit.inc
  30.     include XP40-6:MS Fortran:Include Files:utilities.inc
  31.     include XP40-6:MS Fortran:Include Files:window.inc
  32.     include XP40-6:MS Fortran:Include Files:prport.inc
  33.     include XP40-6:MS Fortran:Include Files:prdefs.inc
  34.     
  35. *    include XP40-6:MS Fortran:Include Files:a5Glob.inc
  36. *
  37. * Local Variables
  38. *
  39.     integer*4 mouseloc        ! mouse location from FINDWINDOW
  40.     integer*4 eventmask        ! specifies the events of interest
  41.     integer*4 window        ! to get default window closed
  42.     integer*4 rnum,rnum1        ! for use in random numbers
  43.  
  44. *
  45. * Include the common variables
  46. *
  47.     include XP40-6:MS Fortran:printgraph.com
  48. *
  49. * lock in control proc handler in memory
  50. *
  51.     window=ctlprc(0,0)
  52. *
  53. *  Flush the event manager before calling
  54. *
  55.     eventmask = -1
  56. *
  57. *  Close MacFortran I/O window 
  58. *
  59.     window=toolbx(FRONTWINDOW)
  60.     call toolbx(CLOSEWINDOW,window)
  61. *
  62. *  Call Text Edit and Dialog initilization.
  63. *
  64.     call toolbx(TEINIT)
  65.     call toolbx(INITDIALOGS, 0)
  66. *
  67. *  Setup a print record for use later and fill in default values
  68. *
  69.     prrechdl=toolbx(NEWHANDLE,iPrintSize)
  70.     call prport(PROPEN)
  71.     call prport(PRINTDEFAULT,prrechdl)
  72.     call prport(PRCLOSE)
  73. *
  74. *  Setup colors array
  75. *
  76.     colors(1)=33
  77.     colors(2)=30
  78.     colors(3)=205
  79.     colors(4)=341
  80.     colors(5)=409
  81.     colors(6)=273
  82.     colors(7)=137
  83.     colors(8)=69
  84. *
  85. * Build the menu from the resource file 
  86. *
  87.     menuhandle=toolbx(GETMENU,Apple)
  88.     call toolbx(INSERTMENU,menuhandle,0)
  89.     call toolbx(ADDRESMENU,menuhandle,'DRVR')
  90.     menuhandle=toolbx(GETMENU,File)
  91.     call toolbx(INSERTMENU,menuhandle,0)
  92.     menuhandle=toolbx(GETMENU,Edit)
  93.     call toolbx(INSERTMENU,menuhandle,0)
  94.     call toolbx(DRAWMENUBAR)
  95. *
  96. * setup rectangles 
  97. *
  98.     call toolbx(SETRECT,rect,0,0,342,512)
  99. *
  100. * setup watch cursor for later use
  101. *
  102.     curshandle=toolbx(GETCURSOR,4)
  103.     call toolbx(HLOCK,curshandle)
  104.     cursptr=long(curshandle)
  105.     call toolbx(BLOCKMOVE,cursptr,toolbx(PTR,watch(1)),68)
  106.     call toolbx(HUNLOCK,curshandle)
  107. *
  108. * seed the random number generator
  109. *
  110.     call toolbx(HIDECURSOR)
  111. *    long(toolbx(GETGLOBAL)+RANDSEED)=toolbx(TICKCOUNT)
  112.     call reset
  113.     call toolbx(SHOWCURSOR)
  114. *
  115. * Setup values for Hilbert curve
  116. *
  117.     rnum=2            ! randomly set color
  118.     do while (rnum=2)    ! don't get white
  119.       rnum1=toolbx(RANDOM)
  120.       rnum=int((abs(rnum1)/32768.0)*8+1)
  121.     repeat
  122.     colorpick=colors(rnum)
  123.     
  124.     rnum=toolbx(RANDOM)    ! randomly set line size
  125.     linepick=int((abs(rnum)/32768.0)*4+1)
  126.     
  127.     rnum=2
  128.     do while (rnum<3)
  129.       rnum1=toolbx(RANDOM)    ! randomly set Hilbert order
  130.       rnum=int((abs(rnum1)/32768.0)*6+1)
  131.     repeat
  132.     n=rnum
  133.  
  134.     call Drawing
  135. *
  136. * main event processing loop
  137. *
  138.     do
  139. *
  140. * handle system jobs
  141. *
  142.     call toolbx(SYSTEMTASK)
  143. *
  144. * handle events
  145. *
  146.     if (toolbx(GETNEXTEVENT,eventmask,eventrecord)) then
  147.       select case (what)
  148.         case (1)    ! mouse down
  149.           mouseloc = toolbx(FINDWINDOW,where,window)
  150.           if (mouseloc=1) then    ! in menu bar
  151.         call menus
  152.           else if (mouseloc=2) then  ! systemwindow
  153.             call toolbx(SYSTEMCLICK,eventrecord,window)
  154.           end if
  155.         case default    ! ignore other events
  156.       end select
  157.     end if
  158.     repeat            ! repeat for another event
  159. *
  160. * end of the main program
  161. *
  162.     end
  163.  
  164. *
  165. * menus: a mouse down event was detected in the menu area
  166. *
  167.     subroutine menus
  168.     
  169.     implicit none
  170. *
  171. * Reset the pathname to reflect your disk setup
  172. *
  173.     include XP40-6:MS Fortran:Include Files:desk.inc
  174.     include XP40-6:MS Fortran:Include Files:dialog.inc
  175.     include XP40-6:MS Fortran:Include Files:event.inc
  176.     include XP40-6:MS Fortran:Include Files:menu.inc
  177.     include XP40-6:MS Fortran:Include Files:memory.inc
  178.     include XP40-6:MS Fortran:Include Files:quickdraw.inc
  179.     include XP40-6:MS Fortran:Include Files:misc.inc
  180.     include XP40-6:MS Fortran:Include Files:textedit.inc
  181.     include XP40-6:MS Fortran:Include Files:utilities.inc
  182.     include XP40-6:MS Fortran:Include Files:window.inc
  183.     include XP40-6:MS Fortran:Include Files:prport.inc
  184.     include XP40-6:MS Fortran:Include Files:prdefs.inc
  185.  
  186.     include XP40-6:MS Fortran:Include Files:OSUtilities.inc
  187.     include XP40-6:MS Fortran:Include Files:scrap.inc
  188.     
  189. *
  190. * local variables for menu subroutine
  191. *
  192.     character*80 name,pname
  193.     integer*4 refnum,item4,i,j,size,count
  194.     integer*2 OSErr
  195.     logical ok
  196. *
  197. * variable for conversion to pascal type strings
  198. *
  199.     character*256 str255
  200. *
  201. *  variables for making menu selections
  202. *
  203.     integer*2 menuselection(2)    ! menu selection information
  204.     integer*4 menudata        ! for use left of equals sign
  205.     equivalence (menuselection,menudata)
  206. *
  207. * Include the common variables
  208. *
  209.     include XP40-6:MS Fortran:printgraph.com
  210. *
  211. * Start of Subroutine
  212. *
  213.     menudata=toolbx(MENUSELECT,where)        ! get selected menu data
  214.     item4=menuselection(2)                ! convert to 4 bytes
  215.     select case (menuselection(1))            ! which menu?
  216.       case (File)    ! File menu
  217.         menuhandle=toolbx(GETMHANDLE,File)
  218.         select case (menuselection(2))
  219.           case(PSetUp)    ! Page Setup selected
  220.             call prport(PROPEN)
  221.               ok=prport(PRSTLDIALOG,prrechdl)
  222.         call prport(PRCLOSE)
  223.           case(PrintPic)    ! Print Hiblert curve selected
  224.               call PrintIt
  225.           case(Quit)    ! Quit selected
  226.         stop
  227.           case default
  228.           end select
  229.        case (Apple)      ! Apple menu
  230.          menuhandle=toolbx(GETMHANDLE,Apple)
  231.          select case(menuselection(2))
  232.            case(About)    ! About item selected
  233.              call toolbx(GETPORT,oldPort)
  234.          dlg=toolbx(GETNEWDIALOG,200,0,-1)
  235.          call toolbx(SETPORT,dlg)
  236.          call FrameDItem
  237.          ditemh=0
  238.          while (ditemh<>1)
  239.            call toolbx(MODALDIALOG,0,ditemh)
  240.          repeat
  241.          call toolbx(SETPORT,oldPort)
  242.          call toolbx(DISPOSEDIALOG,dlg)
  243.            case default    ! desk acc selected
  244.              call toolbx(GETITEM,menuhandle,item4,name)
  245.          refnum=toolbx(OPENDSKACC,name)
  246.            end select
  247.        case (Edit)      ! Edit menu
  248.          if (.not. toolbx(SYSTEMEDIT,item4-1)) then
  249.          end if
  250.        case default        ! just playing with the mouse
  251.     end select
  252.     call toolbx(HILITEMENU,0)
  253.     end
  254.  
  255.  
  256. *
  257. *  Drawing:  create hilbert picture of order n using recursive techniques
  258. *            This is an adaptation of Michael Ackerman's algorithim given
  259. *            in Byte, June 1986, pages 137-148.
  260. *
  261.     subroutine Drawing
  262.     
  263.     implicit none
  264. *
  265. * Reset the pathname to reflect your disk setup
  266. *
  267.     include XP40-6:MS Fortran:Include Files:quickdraw.inc
  268.     include XP40-6:MS Fortran:Include Files:memory.inc
  269.     include XP40-6:MS Fortran:Include Files:misc.inc
  270.     include XP40-6:MS Fortran:Include Files:window.inc
  271. *
  272. * include common variables
  273. *
  274.     include XP40-6:MS Fortran:printgraph.com
  275.  
  276.     call toolbx(SETCURSOR,watch)
  277.  
  278.     call toolbx(SETRECT,rect,0,0,342,512)
  279.     
  280.     pichandle=toolbx(OPENPICTURE,rect)
  281.  
  282.     call toolbx(FORECOLOR,colorpick)
  283.     call toolbx(BACKCOLOR,colors(White))
  284.     call toolbx(PENSIZE,linepick,linepick)
  285.     rder=n
  286.     dy=512/((2**rder-1)+12)
  287.     turn=-1
  288.     dx=0
  289.     x=10
  290.     y=10
  291.     call toolbx(MOVETO,10,10)
  292.     call Graph
  293.  
  294.     call toolbx(CLOSEPICTURE)
  295.  
  296.     call toolbx(FORECOLOR,colors(Black))
  297.     call toolbx(PENSIZE,1,1)
  298.     
  299.     call toolbx(INITCURSOR)
  300.  
  301.     end
  302.  
  303.  
  304. *
  305. * Graph:  draws a hilbert curve of order rder recursively
  306. *
  307.     subroutine Graph
  308.  
  309.     implicit none
  310. *
  311. * Reset the pathname to reflect your disk setup
  312. *
  313.     include XP40-6:MS Fortran:Include Files:quickdraw.inc
  314.     include XP40-6:MS Fortran:Include Files:window.inc
  315. *
  316. * include common variables
  317. *
  318.     include XP40-6:MS Fortran:printgraph.com
  319.  
  320.     integer*4 temp
  321.  
  322.     rder=rder-1
  323.     turn=-turn
  324.     temp=dy
  325.     dy=-turn*dx
  326.     dx=turn*temp
  327.     if (rder.gt.0) call Graph
  328.     x=x+dx
  329.     y=y+dy
  330.     call toolbx(LINETO,x,y)
  331.     turn=-turn
  332.     temp=dy
  333.     dy=-turn*dx
  334.     dx=turn*temp
  335.     if (rder.gt.0) call Graph
  336.     x=x+dx
  337.     y=y+dy
  338.     call toolbx(LINETO,x,y)
  339.     if (rder.gt.0) call Graph
  340.     temp=dy
  341.     dy=-turn*dx
  342.     dx=turn*temp
  343.     turn=-turn
  344.     x=x+dx
  345.     y=y+dy
  346.     call toolbx(LINETO,x,y)
  347.     if (rder.gt.0) call Graph
  348.     temp=dy
  349.     dy=-turn*dx
  350.     dx=turn*temp
  351.     turn=-turn
  352.     rder=rder+1
  353.  
  354.     end    
  355.     
  356.  
  357. *
  358. * Subroutine to print out contents of graph window
  359. *
  360.     Subroutine PrintIt
  361.  
  362.     implicit none
  363. *
  364. * Reset the pathname to reflect your disk setup
  365. *
  366.     include XP40-6:MS Fortran:Include Files:quickdraw.inc
  367.     include XP40-6:MS Fortran:Include Files:dialog.inc
  368.     include XP40-6:MS Fortran:Include Files:memory.inc
  369.     include XP40-6:MS Fortran:Include Files:misc.inc
  370.     include XP40-6:MS Fortran:Include Files:window.inc
  371.     include XP40-6:MS Fortran:Include Files:prport.inc
  372.     include XP40-6:MS Fortran:Include Files:prdefs.inc
  373. *
  374. * other local variables
  375. *
  376.     integer*2 qflag            ! Variable to hold bjDocLoop flag
  377.     integer*4 temp,i
  378.     integer*2 srect(4),margins(4)
  379.     integer*4 rPageptr
  380.     logical ok
  381.     integer*4 canproc
  382. *
  383. * variable for conversion to pascal type strings
  384. *
  385.     character*256 str255,str1
  386. *
  387. * print manager structures
  388. *
  389.     integer*4 theprport        ! Pointer to printer grafport
  390.     integer*1 thestrec(26)        ! Status record for PRPICFILE
  391. *
  392. * include common variables
  393. *
  394.     include XP40-6:MS Fortran:printgraph.com
  395. *
  396. * start print job
  397. *
  398.     call toolbx(HLOCK,prrechdl)
  399.     ok=.false.
  400.     call prport(PROPEN)
  401.     ok=prport(PRJOBDIALOG,prrechdl)
  402.     if (ok) then
  403. *
  404. * set up idle proc
  405. *
  406.       call toolbx(GETPORT,oldPort)
  407.        call toolbx(SETCURSOR,watch)
  408.       canproc=ctlprc(ftrack,0)
  409.       long(long(prrechdl)+prJob+pIdleProc)=canproc
  410.       
  411.       rPageptr=long(prrechdl)+prInfo+rPage
  412.       call toolbx(BLOCKMOVE,rPageptr,toolbx(PTR,srect(1)),8)
  413.       
  414.       dlg=toolbx(GETNEWDIALOG,1010,0,-1)
  415.       str1=str255('Hilbert Order '//char(48+n))
  416.       call toolbx(PARAMTEXT,str1,'','','')
  417.       call toolbx(DRAWDIALOG,dlg)
  418.       call toolbx(SETPORT,dlg)
  419.       call FrameDItem
  420.  
  421.       call toolbx(INITCURSOR)
  422. *
  423. * start printing
  424. *
  425.       theprport = prport(PROPENDOC, prrechdl, 0, 0)
  426.       if (prport(PRERROR) .NE. 0) then
  427.         write(9,*) "Printer error ",prport(PRERROR)
  428.         goto 10
  429.       endif
  430.  
  431.       call prport(PROPENPAGE,theprport,0)
  432.  
  433.       if (prport(PRERROR) .NE. 0) then
  434.         write(9,*) "Printer error ",prport(PRERROR)
  435.         goto 20
  436.       endif
  437.     
  438.       call toolbx(DRAWPICTURE,pichandle,rect)
  439.       
  440. 20      call prport(PRCLOSEPAGE, theprport)
  441. 10      call prport(PRCLOSEDOC, theprport)
  442.  
  443.       qflag = byte(long(prrechdl)+prJob+bJDocLoop)
  444. *
  445. * If the print method is spooled, the actual printing still needs to be done.
  446. *
  447.       if ((qflag = bSpoolLoop) .AND. (prport(PRERROR) = 0)) then
  448.         call prport(PRPICFILE, prrechdl, 0, 0, 0, 
  449.      +          toolbx(PTR,thestrec))
  450.       endif
  451.  
  452.       if (prport(PRERROR) .NE. 0) then
  453.         write(9,*) "Printer error ",prport(PRERROR)
  454.       endif
  455.        call toolbx(DISPOSEDIALOG,dlg)
  456.        call toolbx(SETPORT,oldPort)
  457.     endif
  458.     
  459.     call prport(PRCLOSE)
  460.     call toolbx(HUNLOCK,prrechdl)
  461.     
  462.     end
  463.  
  464. *
  465. *  Frame rounded rectangle, sets the default item
  466. *
  467.     subroutine FrameDItem
  468.  
  469.     implicit none
  470. *
  471. * Reset the pathname to reflect your disk setup
  472. *
  473.     include XP40-6:MS Fortran:Include Files:quickdraw.inc
  474.     include XP40-6:MS Fortran:Include Files:dialog.inc
  475. *
  476. * include common variables
  477. *
  478.     include XP40-6:MS Fortran:printgraph.com
  479. *
  480. * local variables
  481. *
  482.     integer*4 dLog
  483.     integer*2 iBox(4)
  484.     integer*4 iBox4(4)
  485.     integer*2 iType
  486.     integer*4 iHandle
  487.     integer*1 oldPenState(18)
  488.     
  489.     call toolbx(GETPENSTATE,oldPenState)
  490.     call toolbx(GETDITEM,dlg,1,iType,iHandle,iBox)
  491.     call toolbx(INSETRECT,iBox,-4,-4)
  492.     call toolbx(PENSIZE,3,3)
  493.     call toolbx(FRAMEROUNDRECT,iBox,16,16)
  494.     call toolbx(SETPENSTATE,oldPenState)
  495.     
  496.     end
  497. *
  498. *  str255: converts a FORTRAN string to a Pascal LSTRING
  499. *
  500.     character*256 function str255(string)
  501.  
  502.     character*(*) string
  503.     
  504.     str255 = char(len(trim(string)))//string
  505.  
  506.     end
  507.  
  508.  
  509. * This is the idleProc for the Print Manager used in the
  510. * printit subsubroutine.
  511.  
  512. * Normally, a pointer to the arguments passed to a control proc
  513. * routine by the toolbox is passed in argptr.  This is done
  514. * since the glue routine used by ctlprc to interface the
  515. * toolbox to FORTRAN has no way of knowing what kind of
  516. * procedure this is (control actionProc, dialog filterProc,
  517. * etc.), and therefore no way of knowing how many parameters
  518. * to expect.  argptr points to the last argument (partCode)
  519. * as pushed on the stack by the toolbox; preceding arguments
  520. * are at higher addresses.
  521.  
  522.          subroutine ftrack(argptr)
  523.  
  524.     implicit none            ! Declare all variables.
  525.     integer argptr            ! Pointer to arguments.
  526.                     ! but there are none
  527.     logical bool
  528.     integer*2 item
  529.     integer*4 cancelitem
  530.     integer*4 dlgptr,toolbx
  531.     integer*4 mDownMask,KeyDownMask,keyDown
  532.     parameter (cancelitem=1)
  533.     parameter (mDownMask=2,KeyDownMask=8,keyDown=3)
  534.     
  535.     integer*2 theEvent(8)
  536.     integer*2 what
  537.     integer*4 message
  538.     integer*4 when
  539.     integer*2 where(2)
  540.     integer*2 modifiers    
  541.  
  542. *
  543. * Reset the pathname to reflect your disk setup
  544. *
  545.     include XP40-6:MS Fortran:Include Files:event.inc
  546.     include XP40-6:MS Fortran:Include Files:dialog.inc
  547.     include XP40-6:MS Fortran:Include Files:prport.inc
  548.     include XP40-6:MS Fortran:Include Files:prdefs.inc
  549.     
  550.     bool=toolbx(GETNEXTEVENT,mDownMask+KeyDownMask,theEvent)
  551.     item=0
  552.     if ((what=keyDown).and.(mod(message,256) = 13)) then
  553.       item=cancelitem
  554.     else if toolbx(ISDIALOGEVENT,theEvent) then
  555.       bool=toolbx(DIALOGSELECT,theEvent,dlgptr,item)
  556.     end if
  557.     if (item=cancelitem) then
  558.       call prport(PRSETERROR,128)    ! set print abort error
  559.     end if
  560.  
  561.     return
  562.          end
  563.